home *** CD-ROM | disk | FTP | other *** search
/ PsL Monthly 1993 December / PSL Monthly Shareware CD-ROM (December 1993).iso / prgmming / dos / basic / shortsub.bas < prev    next >
BASIC Source File  |  1983-09-13  |  9KB  |  255 lines
  1. 100 REM     --- SHORTSUB ---
  2. 110 REM     BY D.G. PATTERSON
  3. 115 REM     PROGRAM J
  4. 120 REM     9/30/82
  5. 130 REM     SHORT SUBROUTINES
  6. 300 DEFINT I-J
  7. 350 DIM DAT$(20)
  8. 400 KEY OFF:CLS:WIDTH 80:SCREEN 0,0,0:COLOR 6,4
  9. 410 LOCATE 1,25:PRINT "                   "
  10. 420 LOCATE 2,25:PRINT " SHORT SUBROUTINES "
  11. 430 LOCATE 3,25:PRINT " ----------------- "
  12. 440 DATA "(A) Return to menu"
  13. 450 DATA "(B) Yes or no at X1,Y1 location"
  14. 460 DATA "(C) Functions"
  15. 470 DATA "(D) Continue routine"
  16. 480 DATA "(E) Upperfy a string (in X$)"
  17. 490 DATA "(F) Printer error routines (80 COLS)"
  18. 500 DATA "(G) Printer error routines (40 COLS)"
  19. 510 DATA "(H) Load disk A and disk B"
  20. 520 DATA "(I) Sets output for screen or printer"
  21. 530 DATA "(J) Reset function keys"
  22. 540 DATA " "
  23. 550 DATA "(L)"
  24. 560 DATA "(M)"
  25. 570 DATA "(N)"
  26. 580 DATA "(O)"
  27. 590 DATA "(P)"
  28. 600 DATA "(Q)"
  29. 610 DATA "(R)"
  30. 630 FOR J=1 TO 18
  31. 632 READ DAT$(J)
  32. 634 IF DAT$(J)=" " GOTO 640
  33. 636 NEXT J
  34. 640 RESTORE:NR=J-1:CO=1:Y=4
  35. 645 FOR I=1 TO NR
  36. 650 CO=CO+1:IF CO>7 THEN CO=2
  37. 670 Y=Y+1
  38. 680 IF NR < 10 THEN Y = Y+1
  39. 690 COLOR CO,0:LOCATE Y,9:PRINT DAT$(I)
  40. 700 NEXT I
  41. 1000 COLOR 4,0:LOCATE 25,25:PRINT "Enter program desired >" ;
  42. 1010 Q$ = INKEY$:IF Q$="" THEN 1010
  43. 1012 IF Q$=CHR$(3) THEN COLOR 2,0,0:CLS:END
  44. 1013 IF Q$=CHR$(27) THEN COLOR 2,0,0:CLS:END
  45. 1015 PRINT Q$;
  46. 1020 Q=ASC(Q$)
  47. 1030 IF Q >96 AND Q < 97 + NR THEN Q=Q-96:GOTO 1050
  48. 1040 IF Q >64 AND Q < 65 + NR THEN Q=Q-64:GOTO 1050
  49. 1045 LOCATE 25,25:PRINT STRING$(35,32);:GOTO 1000
  50. 1050 COLOR 2,0:WIDTH 80:CLS
  51. 1055 KEY 7,"RUN 1990"+CHR$(13)
  52. 1060 ON Q GOTO 1101,1102,1103,1104,1105,1106,1107,1108,1109,1110,1111,1112,1113,1114,1115,1116,1117,1118
  53. 1101 KEY 7,"TRON"+CHR$(13):RUN "MENU":'A
  54. 1102 LIST 7999-8195,"SCRN:":'B
  55. 1103 LIST 8199-8395,"SCRN:":'C
  56. 1104 LIST 8399-8595,"SCRN:":'D
  57. 1105 LIST 8599-8795,"SCRN:":'E
  58. 1106 LIST 8799-8995,"SCRN:":'F
  59. 1107 LIST 8999-9195,"SCRN:":'G
  60. 1108 LIST 9199-9395,"SCRN:":'H
  61. 1109 LIST 9399-9595,"SCRN:":'I
  62. 1110 LIST 9599-9795,"SCRN:":'J
  63. 1111 LIST 9799-9995,"SCRN:":'K
  64. 1112 LIST 9999-10195,"SCRN:":'L
  65. 1113 LIST 10199-10395,"SCRN:":'M
  66. 1114 LIST 10399-10595,"SCRN:":'N
  67. 1115 LIST 10599-10795,"SCRN:":'O
  68. 1116 LIST 10799-10995,"SCRN:":'P
  69. 1117 LIST 10999-11195,"SCRN:":'Q
  70. 1118 LIST 11199-11395,"SCRN:":'R
  71. 1990 KEY 7,"TRON"+CHR$(13)
  72. 2000 COLOR 6,0,0
  73. 2010 Y1=25:X1=20
  74. 2020 LOCATE 25,1:PRINT STRING$(79,CHR$(32));:LOCATE Y1,X1
  75. 2030 PRINT "DO YOU WISH TO USE THIS SUBROUTINE > ";
  76. 2040 POKE 106,0
  77. 2050 A1$=INKEY$:IF A1$="" THEN 2050
  78. 2060 PRINT A1$;
  79. 2070 IF A1$=CHR$(3) THEN SCREEN 0,0,0:CLS:COLOR 2,0,0:WIDTH 80:END
  80. 2080 IF A1$=CHR$(27) THEN SCREEN 0,0,0:CLS:COLOR 2,0,0:WIDTH 80:RUN "MENU"
  81. 2090 IF A1$="y" OR A1$="Y" THEN LOCATE 25,1:PRINT STRING$(79,CHR$(32));:LOCATE Y1,10:COLOR 7:PRINT "CHANGE TO WORKING DISK AND ENTER SUBROUTINE LETTER > ";:GOTO 2102
  82. 2100 GOTO 300
  83. 2102 Q$=INKEY$:IF Q$="" THEN 2102
  84. 2104 IF Q$=CHR$(27) THEN COLOR 2,0,0:CLS:RUN "MENU
  85. 2106 PRINT Q$
  86. 2108 Q=ASC(Q$)
  87. 2110 IF Q > 96 AND Q < 115 THEN Q=Q-96:GOTO 2116
  88. 2112 IF Q > 64 AND Q < 83  THEN Q=Q-64:GOTO 2116
  89. 2114 LOCATE 25,25:PRINT STRING$(35,32);:GOTO 2090
  90. 2116 COLOR 2,0:WIDTH 80:CLS
  91. 2120 COLOR 12,0,0:LOCATE 1,21:PRINT STRING$(79,32);:LOCATE Y1,21:PRINT    "SUBROUTINE NOW SAVED IN FILE    SUB-";Q$;:PRINT CHR$(11):COLOR 2,0,0
  92. 2130 ON Q GOTO 2140,2150,2160,2170,2180,2190,2200,2210,2220,2230,2240,2250,2260,2270,2280,2290,2300,2310
  93. 2140 RUN "MENU"
  94. 2150 LIST 7999-8190,"SUB-B"
  95. 2160 LIST 8199-8390,"SUB-C"
  96. 2170 LIST 8399-8590,"SUB-D"
  97. 2180 LIST 8599-8790,"SUB-E"
  98. 2190 LIST 8799-8990,"SUB-F"
  99. 2200 LIST 8999-9190,"SUB-G"
  100. 2210 LIST 9199-9390,"SUB-H"
  101. 2220 LIST 9399-9590,"SUB-I"
  102. 2230 LIST 9599-9790,"SUB-J"
  103. 2240 LIST 9799-9990,"SUB-K"
  104. 2250 LIST 9999-10190,"SUB-L"
  105. 2260 LIST 10199-10390,"SUB-M"
  106. 2270 LIST 10399-10590,"SUB-N"
  107. 2280 LIST 10599-10790,"SUB-O"
  108. 2290 LIST 10799-10990,"SUB-P"
  109. 2300 LIST 10999-11190,"SUB-Q"
  110. 2310 LIST 11199-11390,"SUB-R"
  111. 2320 END
  112. 7999 END
  113. 8000 REM    ***** YES OR NO AT X1,Y1 LOCATION *****
  114. 8001 '
  115. 8010 Y1=10:X1=20
  116. 8020 LOCATE Y1,1:PRINT STRING$(79,CHR$(32));
  117. 8030 LOCATE Y1,X1:COLOR 6,0,0:PRINT "ANSWER YES OR NO > ";
  118. 8050 B1$=INKEY$:IF B1$="" THEN 8050
  119. 8060 PRINT B1$;
  120. 8070 IF B1$=CHR$(3) THEN SCREEN 0,0,0:CLS:COLOR 2,0,0:WIDTH 80:END
  121. 8080 IF B1$=CHR$(27) THEN SCREEN 0,0,0:CLS:COLOR 2,0,0:WIDTH 80:RUN "MENU"
  122. 8090 IF B1$="y" OR B1$="Y" THEN RETURN
  123. 8100 IF B1$="n" OR B1$="N" THEN RETURN
  124. 8110 GOTO 8020
  125. 8193 '
  126. 8194 '
  127. 8195 '          SUBROUTINE IS    SUB-B          HIT F7 KEY
  128. 8199 END
  129. 8200 REM    ***** FUNCTIONS *****
  130. 8201 '
  131. 8210 '-- TIME IN SECONDS --
  132. 8220 DEF FNTIME=VAL(LEFT$(TIME$,2))*3600+VAL(MID$(TIME$,4,2))*60+VAL(RIGHT$(TIME$,2))
  133. 8230 ' -- RETURNS UPERCASE FIRST LETTER OF A STRING --
  134. 8240  DEF FNU$(A$)=CHR$(ASC(LEFT$(A$,1))+32*(LEFT$(A$,1)>"Z"))
  135. 8250 ' -- STRIPS LEADING SPACE FROM A NUMBER CONVERTED TO A STRING --
  136. 8260 DEF FNS$(N$)=RIGHT$(N$,LEN(N$)-1)
  137. 8270 DEF SEG=&H40;POKE &H17,PEEK(&H17) OR 32:' TO SET NUMLOCK
  138. 8271 DEF SEG=&H40;POKE &H17,PEEK(&H17) AND 223 :' TO UNSET NUMLOCK
  139. 8272 DEF SEG=&H40;POKE &H17,PEEK(&H17) OR 64:' TO SET CAPSLOCK
  140. 8273 DEF SEG=&H40;POKE &H17,PEEK(&H17) AND 171 :' TO UNSET CAPSLOCK
  141. 8393 '
  142. 8394 '
  143. 8395 '          SUBROUTINE 1S    SUB-C          HIT F7 KEY
  144. 8399 END
  145. 8400 REM    ***** CONTINUE ROUTINE *****
  146. 8401 '
  147. 8410 LOCATE 25,1:PRINT STRING$(79,32);:LOCATE 25,27
  148. 8420 COLOR 5,0,0:PRINT "Hit any key to continue";:COLOR 2,0,0
  149. 8440 B2$=INKEY$:IF B2$="" THEN 8440
  150. 8460 IF B2$=CHR$(3) THEN SCREEN 0,0,0:CLS:COLOR 2,0,0:WIDTH 80:END
  151. 8470 IF B2$=CHR$(27) THEN SCREEN 0,0,0:CLS:COLOR 2,0,0:WIDTH 80:RUN "MENU"
  152. 8480 CLS
  153. 8490 RETURN
  154. 8593 '
  155. 8594 '
  156. 8595 '          SUBROUTINE IS    SUB-D          HIT F7 KEY
  157. 8599 END
  158. 8600 '          ***** UPERFY A STRING *****
  159. 8601 '
  160. 8610 FOR XZ=1 TO LEN(X$)
  161. 8620 XC$=MID$(X$,XZ,1)
  162. 8630 IF "a" <= XC$ AND XC$ <= "z" THEN MID$(X$,XZ,1) = CHR$(ASC(XC$)-32)
  163. 8640 NEXT XZ
  164. 8650 RETURN
  165. 8793 '
  166. 8794 '
  167. 8795 '          SUBROUTINE IS    SUB-E          HIT F7 KEY
  168. 8799 END
  169. 8800 '          ***** PRINTER ERROR ROUTINES (80 COL) *****
  170. 8801 '
  171. 8805 IF ERR=24 THEN RESUME ELSE GOTO 8810
  172. 8810 LOCATE 25,1:PRINT SPACE$(79);
  173. 8820 IF ERR=25 THEN 8830 ELSE 8850
  174. 8830 COLOR 4,0,0:LOCATE 25,25:LINE INPUT ;"Turn printer on and (CR)";Z$
  175. 8840 LOCATE 25,1:PRINT SPACE$(79);:COLOR 2,0,0:RESUME
  176. 8850 SCREEN 0,0,0:CLS:COLOR 2,0,0:WIDTH 80:ON ERROR GOTO 0
  177. 8993 '
  178. 8994 '
  179. 8995 '          SUBROUTINE IS    SUB-F          HIT F7 KEY
  180. 8999 END
  181. 9000 '          ***** PRINTER ERROR ROUTINES (40 COL) *****
  182. 9001 '
  183. 9005 IF ERR=24 THEN RESUME ELSE GOTO 9010
  184. 9010 LOCATE 25,1:PRINT SPACE$(39);
  185. 9020 IF ERR=25 THEN 9030 ELSE 9050
  186. 9030 COLOR 4:LOCATE 25,7:LINE INPUT ;"Turn printer on and (CR)";Z$
  187. 9040 LOCATE 25,1:PRINT SPACE$(39);:COLOR 2,0,0:RESUME
  188. 9050 SCREEN 0,0,0:CLS:COLOR 2,0,0:WIDTH 80:ON ERROR GOTO 0
  189. 9193 '
  190. 9194 '
  191. 9195 '          SUBROUTINE IS    SUB-G          HIT F7 KEY
  192. 9199 END
  193. 9200 '          ***** Load disk A and disk B *****
  194. 9210 '
  195. 9220 DSK=1:DSK1$="DISK A":DSK2$="DISK B":CLS:WIDTH 40
  196. 9230 LOCATE 4,6:COLOR 12:PRINT "Hit ESC to abort"
  197. 9240 LOCATE 6,6:PRINT "Hit any key to load both disks"
  198. 9250 B3$=INKEY$:IF B3$="" THEN 9250
  199. 9260 IF B3$=CHR$(3) THEN SCREEN 0,0,0:CLS:COLOR 2,0,0:WIDTH 80:END
  200. 9270 IF B3$=CHR$(27) THEN SCREEN 0,0,0:CLS:COLOR 2,0,0:WIDTH 80:RUN "MENU"
  201. 9273 IF DSK > 2 GOTO 9390
  202. 9276 IF DSK=1 THEN LOCATE 10,6:COLOR 25,6:PRINT " LOADING  ";:COLOR 9,6:PRINT DSK1$;" ":COLOR 2,0
  203. 9278 IF DSK=2 THEN LOCATE 10,6:COLOR 16,7:PRINT " LOADING  ";:COLOR 0,7:PRINT DSK1$;" ":COLOR 2,0
  204. 9280 FILDAT$="NAME"     :REM  --------CHANGE TO REAL NAME-------
  205. 9290 IF DSK=1 THEN FILDAT$="A:"+FILDAT$
  206. 9300 IF DSK=2 THEN FILDAT$="B:"+FILDAT$
  207. 9310 REM    -----ENTER INSTRUCTIONS HERE-----
  208. 9370 CLOSE #1
  209. 9375 BEEP:DSK=DSK+1:SWAP DSK1$,DSK2$
  210. 9380 LOCATE 10,6:PRINT SPC(39):GOTO 9273
  211. 9390 WIDTH 80:COLOR 2,0,0:RUN "MENU"
  212. 9393 '
  213. 9395 '          SUBROUTINE IS    SUB-H          HIT F7 KEY
  214. 9399 END
  215. 9400 '          ***** DIRECT OUTPUT TO PRINTER OR SCREEN *****
  216. 9410 '
  217. 9420 DEF FNU$(A$)=CHR$(ASC(LEFT$(A$,1))+32*(LEFT$(A$,1)>"Z"))
  218. 9430 DEV$="SCRN:"
  219. 9440 WIDTH 40:COLOR 14,1,9:CLS:LOCATE 12,3:PRINT "Do you wish output on the printer ";
  220. 9450 B2$=INKEY$:IF B2$="" THEN 9450
  221. 9460 PRI